home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / runtime / callgc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-02-09  |  26.4 KB  |  1,010 lines
  1. /* callgc.c
  2.  *
  3.  * COPYRIGHT (c) 1990 by AT&T Bell Laboratories.
  4.  */
  5.  
  6. #include "ml_os.h"
  7. #include "ml_state.h"
  8. #include "ml_types.h"
  9. #include "tags.h"
  10. #include "cause.h"
  11. #include "request.h"
  12. #include "sync.h"
  13. #ifndef THINK_C
  14. #include <sys/signal.h>
  15. #else
  16. #include <signal.h>
  17. #endif
  18.  
  19. #define refcell(z)    \
  20.     ML_val_t z[2] = {(ML_val_t)MAKE_DESC(1,TAG_array), INT_CtoML(0)};
  21.  
  22. refcell(collected0)
  23. refcell(collectedfrom0)
  24. refcell(times0)
  25. refcell(current0)
  26. refcell(gcmessages0)
  27. refcell(majorcollections0)
  28. refcell(minorcollections0)
  29. refcell(pstruct0)
  30. refcell(ratio0)
  31. refcell(sighandler0)
  32. refcell(softmax0)
  33. refcell(lastratio0)
  34.  
  35. #define collected (collected0[1])
  36. #define collectedfrom (collectedfrom0[1])
  37. #define current (current0[1])
  38. #define gcmessages (gcmessages0[1])
  39. #define majorcollections (majorcollections0[1])
  40. #define minorcollections (minorcollections0[1])
  41. #define pstruct (pstruct0[1])
  42. #define ratio (ratio0[1])
  43. #define softmax (softmax0[1])
  44. #define lastratio (lastratio0[1])
  45.  
  46. #define DEFAULT_CHUNK_SIZE (1024 * 512)               /* 1/2 Meg */
  47. #define MIN_CHUNK_SIZE     (1024 * 128)               /* 1/8 Meg */
  48. #define MAX_CHUNK_SIZE     (1024 * 1024)              /* 1 meg   */
  49. #define DEFAULT_HEAP_SIZE ((MAX_PROCS) * 1024 * 1024) /* 1 meg per proc */
  50.  
  51. int chunk_size = DEFAULT_CHUNK_SIZE;
  52. #if (MAX_PROCS > 1)
  53. volatile int gcMaster = 0;
  54. #else /* (MAX_PROCS == 1) */
  55. int gcMaster = 0;
  56. #endif
  57. extern spin_lock_t MLproc_lock;
  58. extern MLState_t *MLproc;
  59. extern void block();
  60. extern void unblock();
  61.  
  62. int        arenabase;               /* bottom of the heap */
  63. int        arenasize = 0;           /* heap starts empty */
  64. int        new_size = DEFAULT_HEAP_SIZE;
  65. int        arstart;                 /* beginning of allocation arena */
  66. int        arend;                   /* end of main arena, and the heap */
  67. int        old_high;                /* marks end of persistent heap */
  68. int        new_high;
  69. int        new_new_high;
  70. int        lastbreak;
  71. int             shouldFlush1 = FALSE;
  72. int             shouldFlush2 = FALSE;
  73. int             flushFrom1, flushFrom2;
  74. int             flushTo1, flushTo2;
  75.  
  76. static int    pagesize;
  77.  
  78. ML_val_t    store_preserve = INT_CtoML(0);
  79. ML_val_t        empty_store_lists[1] = {0};
  80. int        preserving = 0;
  81.  
  82. void callgc0 ();
  83. static void callgc ();
  84. static int **getmore_die ();
  85. static int **getmore_must ();
  86. #ifdef NeXT
  87. static int brk(), sbrk();
  88. #endif
  89.  
  90. /* divideAllocArea:
  91.  * Divide the allocation area among the processor states.  Each non-running
  92.  * proc state receives a minimum-size chunk (128k).  The rest of the area
  93.  * is divided equally among the running proc states.  However, each proc's
  94.  * area is further subdivided into chunks (between 128k and 512k in size).
  95.  * The proc starts off with the first chunk in its area.
  96.  *
  97.  * When a proc faults, it tries to get another chunk from its own area.
  98.  * If it fails, it tries to "steal" a chunk from another proc's area.
  99.  * If this fails, it forces the other procs to do a GC and re-divide the
  100.  * allocation area.
  101.  */
  102. void divideAllocArea(MLState, allocStart, allocLimit)
  103.      MLState_ptr MLState;
  104.      int allocStart, allocLimit;
  105. {
  106.   MLState_t *p;
  107.   int i;
  108.   int live_procs = 0;
  109.   int procHeapSize;
  110.   int next_chunk = allocStart & (~3);
  111.   int max_chunk_size, min_chunk_size;
  112.  
  113. #if (MAX_PROCS > 1)
  114.   max_chunk_size = ((allocLimit - allocStart) / MAX_PROCS) & (~3);
  115.   max_chunk_size = (max_chunk_size > MAX_CHUNK_SIZE) ? MAX_CHUNK_SIZE :
  116.     max_chunk_size;
  117.   min_chunk_size = (max_chunk_size < MIN_CHUNK_SIZE) ? max_chunk_size :
  118.     MIN_CHUNK_SIZE;
  119.   chunk_size = (DEFAULT_CHUNK_SIZE < max_chunk_size) ? DEFAULT_CHUNK_SIZE :
  120.     max_chunk_size;
  121.   chunk_size = (chunk_size > min_chunk_size) ? chunk_size :
  122.     min_chunk_size;
  123. #else
  124.   chunk_size = ((allocLimit - allocStart) / MAX_PROCS) & (~3);
  125.   min_chunk_size = 0;  /* to avoid complaints about uninitialized vars */
  126. #endif
  127.  
  128.   /* Give non-running procs only minimum-size chunk of allocation space */
  129.   for (i = 0; i < MAX_PROCS; i++) {
  130.     p = &(MLproc[i]);
  131.     if (p->state != MLPROC_RUNNING) {
  132.       p->ml_allocptr = next_chunk;
  133.       p->alloc_boundary = next_chunk + min_chunk_size;
  134.       p->ml_limitptr = p->alloc_boundary - 4096;
  135.       p->max_allocptr = next_chunk;
  136.       next_chunk += min_chunk_size;
  137.     } else 
  138.       live_procs++;
  139.   }
  140.   
  141.   procHeapSize = ((allocLimit - next_chunk) / live_procs) & (~3);
  142.   chunk_size = (procHeapSize < chunk_size) ? procHeapSize : chunk_size;
  143.   
  144.   /* give each proc an allocation area and a starting chunk within it */
  145.   for (i=0; i < MAX_PROCS; i++) {
  146.     p = &(MLproc[i]);
  147.     if (p->state == MLPROC_RUNNING) {
  148.       p->ml_allocptr = next_chunk;
  149.       p->max_allocptr = next_chunk;
  150.       p->alloc_boundary = next_chunk + procHeapSize;
  151.       p->ml_limitptr = next_chunk + chunk_size - 4096;
  152.       next_chunk += procHeapSize;
  153.     }
  154.   }
  155.  
  156. #ifdef MP_GC_DEBUG
  157.     chatting("[alloc area: %x-%x, chunk_size = %x]\n",
  158.          allocStart, allocLimit, chunk_size);
  159.  
  160.   for (i=0; i < MAX_PROCS; i++) {
  161.     p = &(MLproc[i]);
  162.     chatting("[MLproc[%d]: alloc = %d, limit = %d,\n",
  163.          i, p->ml_allocptr,p->ml_limitptr);
  164.     chatting("            (%dk), bound = %d (%dk)]\n",
  165.          (p->ml_limitptr - p->ml_allocptr)/1024,
  166.          p->alloc_boundary,
  167.          (p->alloc_boundary - p->ml_allocptr)/1024);
  168.   }
  169. #endif MP_GC_DEBUG
  170.  
  171. #ifdef MP_DEBUG
  172.   /* sanity check */
  173.   if (next_chunk > allocLimit) 
  174.     die("next_chunk = %x, allocLimit = %x\n",next_chunk,allocLimit);
  175. #endif MP_DEBUG
  176. }
  177.  
  178.  
  179. /* new_chunk:
  180.  * Try to find a new chunk instead of forcing a GC sync -- return TRUE
  181.  * if successful.
  182.  */
  183. int new_chunk(MLState)
  184.      MLState_ptr MLState;
  185. {
  186.   MLState_t *p;
  187.   int found_space = FALSE;
  188.   int i;
  189.   int local_chunk_size;
  190.   int amount = MLState->amount + 4096;
  191.   int cur_limitptr = MLState->ml_limitptr;
  192.   int max_limitptr = MLState->alloc_boundary - 4096;
  193.   
  194.   local_chunk_size = (chunk_size < amount) ? amount : chunk_size;
  195.  
  196.   if ((cur_limitptr + local_chunk_size) > max_limitptr) {
  197.   /* not enough space for a chunk, but maybe enough space for amount */
  198.     if ((cur_limitptr + amount) > max_limitptr) {
  199.     /* not enough space in our allocation area, so look for a chunk to steal */
  200.       for (i=0; (i < MAX_PROCS) && (!found_space); i++) {
  201.     p = &(MLproc[i]);
  202.     if (p != MLState) {
  203.       if ((p->alloc_boundary - local_chunk_size) > 
  204.           (p->ml_limitptr + 4096)) {
  205.         /* we can steal a full chunk from p */
  206.         MLState->alloc_boundary = p->alloc_boundary;
  207.         MLState->ml_limitptr = p->alloc_boundary - 4096;
  208.         MLState->ml_allocptr = p->alloc_boundary - local_chunk_size;
  209.         p->alloc_boundary = MLState->ml_allocptr;
  210.         found_space = TRUE;
  211. #ifdef MP_GC_DEBUG
  212.         chatting("[stole chunk from MLproc[%d]]\n",i);
  213. #endif MP_GC_DEBUG
  214.  
  215.       } else if ((p->alloc_boundary - amount) >
  216.              (p->ml_limitptr + 4096)) {
  217.         /* we can steal the amount needed from p */
  218.         MLState->alloc_boundary = p->alloc_boundary;
  219.         MLState->ml_limitptr = p->alloc_boundary - 4096;
  220.         MLState->ml_allocptr = p->alloc_boundary - amount;
  221.         p->alloc_boundary = MLState->ml_allocptr;
  222.         found_space = TRUE;
  223. #ifdef MP_GC_DEBUG
  224.         chatting("[stole amount from MLproc[%d]]\n",i);
  225. #endif MP_GC_DEBUG
  226.       }
  227.     }
  228.       }
  229.     } else {
  230.       /* enough space for amount -- just set limit to end of our area */
  231.       MLState->ml_limitptr = max_limitptr;
  232.       found_space = TRUE;
  233.  
  234. #ifdef MP_GC_DEBUG
  235.       chatting("[found amount]\n");
  236. #endif MP_GC_DEBUG
  237.  
  238.     }
  239.   } else {
  240.   /* enough space for a chunk */
  241.     MLState->ml_limitptr = cur_limitptr + local_chunk_size;
  242.     found_space = TRUE;
  243.  
  244. #ifdef MP_GC_DEBUG
  245.     chatting("[found chunk]");
  246. #endif MP_GC_DEBUG
  247.  
  248.   }
  249.  
  250. #ifdef MP_GC_DEBUG
  251.   if (found_space)
  252.     chatting("[alloc = %x, limit = %x, bound = %x]\n",
  253.          MLState->ml_allocptr, MLState->ml_limitptr, 
  254.          MLState->alloc_boundary);
  255. #endif MP_GC_DEBUG
  256.  
  257.   return (found_space);
  258. }
  259.  
  260.  
  261. /* init_gc:
  262.  */
  263. void init_gc (MLState)
  264.      MLState_ptr MLState;
  265. {
  266.     pagesize         = getpagesize();
  267.     arenabase         = sbrk(0);
  268.     lastbreak         = arenabase;
  269.     increase_heapsize();
  270.     old_high         = arenabase;
  271. #ifdef CACHE_SIZE
  272.     arstart              = arenabase+arenasize-CACHE_SIZE;
  273. #else
  274.     arstart              = ((arenabase+arenasize/2)+3)&(~3);
  275. #endif
  276.     collected         = INT_CtoML(0);
  277.     collectedfrom     = INT_CtoML(0);
  278.     minorcollections     = INT_CtoML(0);
  279.     majorcollections     = INT_CtoML(0);
  280.  
  281.     divideAllocArea(MLState, arstart, arenabase+arenasize);
  282.     lastratio            = INT_CtoML(0);
  283. }
  284.  
  285. /* restart_gc:
  286.  */
  287. void restart_gc(MLState)
  288.      MLState_ptr MLState;
  289. {
  290.     int        live_size = old_high - arenabase;
  291.     int        a = 0;
  292.     ML_val_t    x = gcmessages;
  293.  
  294.     resettimers();
  295.     lastbreak = EDATA;
  296. #ifdef THINK_C
  297.     gcmessages = INT_CtoML(2);
  298. #else
  299.     gcmessages = INT_CtoML(0);
  300. #endif
  301.     new_size = compute_new_size(live_size);
  302.     do {
  303.     increase_heapsize();
  304.     if (arenasize == a)
  305.         die("Can't get enough memory to start ML\n");
  306.     a = arenasize;
  307.     } while (arenasize < 3*live_size);
  308.     gcmessages = x;
  309.     lastratio = INT_CtoML(arenasize/(live_size/100));
  310. #ifdef ADVICE
  311.     ostime=zero; otime=zero; ogtime=zero;
  312.     getting_advice=1;
  313.     initadvice();
  314. #endif
  315.     divideAllocArea(MLState, arstart, lastbreak);
  316. } /* end of restart_gc */
  317.  
  318.  
  319. /* check_heap:
  320.  * Check the heap to insure that there is a sufficient amount of available
  321.  * memory in the allocation arena.  If not, then do a garbage collection and
  322.  * return 1, otherwise return 0.
  323.  * NOTE: if a garbage collection is done, then any roots in C variables (other
  324.  * than the ML state vector) are obsolete.
  325.  */
  326. int check_heap (MLState,amount)
  327.     MLState_ptr MLState;
  328.     int        amount;
  329. {
  330.     register int    top = MLState->ml_limitptr;
  331.  
  332.     if ((MLState->ml_allocptr + amount) >= top) {
  333.     if (gcmessages >= INT_CtoML(3))
  334.         chatting("[check_heap: %d bytes available, %d required]\n",
  335.         (top + 4096) - MLState->ml_allocptr, amount+4096);
  336.  
  337.     callgc0 (MLState, CAUSE_GC, amount);
  338.     return 1;
  339.     }
  340.     else
  341.     return 0;
  342.  
  343. } /* end of check_heap */
  344.  
  345.  
  346. /* collect_roots:
  347.  * Collect all of the roots from the active processors (and their storelists)
  348.  * and pass them off to callgc.
  349.  */
  350. void collect_roots (MLState, cause)
  351.     MLState_ptr MLState;
  352.     int        cause;
  353. {
  354.     int        i;
  355.     int         *roots[((NROOTS+5)*MAX_PROCS)+5];
  356.     int         mask, j;
  357.     MLState_t   *p;
  358.     ML_val_t    store_lists[MAX_PROCS+1];
  359.     ML_val_t    *storeptr = store_lists;
  360.     int         max_allocptr = MLState->ml_allocptr;
  361.     int        **rootsptr = roots;
  362.     int         total_amount = 0;
  363.     ML_val_t    currentsave = current;
  364.  
  365.     current = INT_CtoML(2);
  366.  
  367.     start_gc_timer();
  368.     *rootsptr++ = (int *) (times0+1);
  369.     *rootsptr++ = (int *) &pstruct;
  370.     *rootsptr++ = (int *) &store_preserve;
  371.     *rootsptr++ = (int *) &(sighandler0[1]);
  372.  
  373.     for (j=0; j < MAX_PROCS; j++) {
  374.       p = &(MLproc[j]);
  375.       /* add running proc's roots */
  376.       if (p->state == MLPROC_RUNNING) {
  377. #ifdef MP_DEBUG
  378.     pchatting(MLState,"[adding %d's roots]\n",p->self);
  379. #endif MP_DEBUG
  380.     *rootsptr++ = (int *) &(p->ml_pc);
  381.     *rootsptr++ = (int *) &(p->ml_exncont);
  382.     *rootsptr++ = (int *) &(p->ml_varptr);
  383. #ifdef BASE_INDX
  384.     *rootsptr++ = (int *) &(p->ml_baseptr);
  385. #endif
  386. #ifdef GLOBAL_INDX
  387.     *rootsptr++ = (int *) &(p->ml_globalptr);
  388. #endif
  389. /*    chatting("\n[pc 0x%x, 0x%x]",p->ml_pc,p->mask); */
  390.     mask = p->mask;
  391.     for (i = 0;  mask != 0;  i++, mask >>= 1) {
  392.       if ((mask & 1) != 0)
  393.         *rootsptr++ = (int *)&(p->ml_roots[ArgRegMap[i]]);
  394.     }
  395.     total_amount += p->amount;
  396.       }
  397.       max_allocptr = (p->max_allocptr > max_allocptr) ? p->max_allocptr :
  398.     max_allocptr;
  399.       /* add the proc's store list to the vector of store lists */
  400.       if (p->ml_storeptr != (int)STORLST_nil) {
  401.     *storeptr++ = (ML_val_t)p->ml_storeptr;
  402.     p->ml_storeptr = (int)STORLST_nil;
  403.       }
  404.     }
  405.     *rootsptr = 0;
  406.     *storeptr = 0;
  407. #ifdef MP_DEBUG
  408.     pchatting(MLState,"[callgc]\n");
  409. #endif MP_DEBUG
  410.     shouldFlush1 = FALSE;
  411.     shouldFlush2 = FALSE;
  412.     callgc(MLState, cause, roots, &max_allocptr, store_lists, total_amount);
  413.     divideAllocArea(MLState, max_allocptr, arend);
  414.     current = currentsave;
  415.  
  416.     stop_gc_timer();
  417.  
  418. } /* end of collect_roots */
  419.  
  420.  
  421. #if (MAX_PROCS > 1)
  422. /* Force other procs to synchronize for GC */
  423. void
  424. gcMaster_sync(MLState, cause)
  425.      MLState_ptr MLState;
  426.      int cause;
  427. {
  428.   int i;
  429.   MLState_t *p;
  430.   int live_procs = 0;
  431.  
  432.   /* send a GC sync signal to other running procs */
  433.   for (i=0; i < MAX_PROCS; i++) {
  434.     p = &(MLproc[i]);
  435.     if ((p->self != MLState->self) && (p->state == MLPROC_RUNNING)) {
  436.       p->GCpending = TRUE;
  437. #ifdef MP_DEBUG
  438.       pchatting(MLState,"[signalling %d]\n",p->self);
  439. #endif MP_DEBUG
  440.       signalproc(p->self);
  441.       live_procs++;
  442.     }
  443.   }
  444.   /* wait for others to check in */
  445.   for (i=0; i < live_procs; i++)
  446.     block(MLState->self);
  447.   /* all have checked in -- do the gc.  At this point, all other
  448.      procs are blocked. */
  449. #ifdef MP_DEBUG
  450.   pchatting(MLState,"[gc sync complete]\n");
  451. #endif MP_DEBUG
  452.   collect_roots(MLState, cause);
  453.   /* wake others up for cache flush */
  454.   for (i=0; i < MAX_PROCS; i++) {
  455.     p = &(MLproc[i]);
  456.     if ((p->self != MLState->self) && (p->state == MLPROC_RUNNING)) {
  457.       p->GCpending = FALSE;
  458. #ifdef MP_DEBUG
  459.       pchatting(MLState,"[waking %d]\n",p->self);
  460. #endif MP_DEBUG
  461.       unblock(p->self);
  462.     }
  463.   }
  464.   for (i=0; i < live_procs; i++)
  465.     block(MLState->self);
  466. #ifdef MP_DEBUG
  467.   pchatting(MLState,"[master resuming.]\n");
  468. #endif MP_DEBUG
  469. } /* end gcMaster_sync */
  470.  
  471.  
  472. /* synchronize with the GC master and wait for it to finish GC. */
  473. void gcSlave_sync(MLState)
  474.      MLState_ptr MLState;
  475. {
  476. #ifdef MP_DEBUG
  477.   pchatting(MLState,"[syncing with master.]\n");
  478. #endif MP_DEBUG
  479.   unblock(gcMaster);
  480.   /* Wait until master wakes us -- GC will be done at this point */
  481.   block(MLState->self);
  482.   /* Flush i-cache if necessary and inform Master when through */
  483.   if (shouldFlush1) 
  484.     FlushICache(flushFrom1, flushTo1);
  485.   if (shouldFlush2)
  486.     FlushICache(flushFrom2, flushTo2);
  487.   unblock(gcMaster);
  488. #ifdef MP_DEBUG
  489.   pchatting(MLState,"[slave resuming.]\n");
  490. #endif MP_DEBUG
  491. } /* end gcSlave_sync */
  492.  
  493.  
  494. void
  495. callgc0 (MLState, cause, amount)
  496.      MLState_ptr MLState;
  497.      int cause, mask;
  498. {
  499.   extern int should_exit;
  500.  
  501.   if (should_exit) 
  502.     mp_shutdown(MLState, 0);
  503.  
  504.   if (MLState->max_allocptr < MLState->ml_allocptr)
  505.     MLState->max_allocptr = MLState->ml_allocptr;
  506.   MLState->amount = amount;
  507.  
  508.   /* Try to grab the MLproc_lock, but check for other pending GC's */
  509. #ifdef MP_DEBUG
  510.   pchatting(MLState,"[entered callgc0]\n");
  511. #endif MP_DEBUG
  512.   while ((!try_spin_lock(MLproc_lock)) &&
  513.      (!MLState->GCpending)) /* spin */ ;
  514.  
  515.   if (MLState->GCpending) {
  516.     /* We failed to acquire the lock, but a GC master has set our GCpending
  517.        flag, so synchronize with the master. */
  518.     gcSlave_sync(MLState);
  519.   } else {
  520.   /* We succeeded in acquiring the lock, so we have control over GC.
  521.      If cause != CAUSE_GC, then we have to do a synch.  Otherwise,
  522.      try to just get a new chunk before resorting to a synch. */
  523.  
  524.     if ((cause != CAUSE_GC) || (! new_chunk(MLState))) {
  525. #ifdef MP_DEBUG
  526.       pchatting(MLState,"[setting self to master.]\n");
  527. #endif MP_DEBUG
  528.       gcMaster = MLState->self;
  529.       gcMaster_sync(MLState, cause);
  530.       gcMaster = 0;
  531.     }
  532. #ifdef MP_DEBUG
  533.     pchatting(MLState,"[releasing lock]\n");
  534. #endif MP_DEBUG
  535.     spin_unlock(MLproc_lock);
  536.   }
  537. }
  538. #else /* (MAX_PROCS <= 1) */
  539. void
  540. callgc0 (MLState, cause, amount)
  541.      MLState_ptr MLState;
  542.      int cause;
  543. {
  544.   if (MLState->max_allocptr < MLState->ml_allocptr)
  545.     MLState->max_allocptr = MLState->ml_allocptr;
  546.   MLState->amount = amount;
  547.   collect_roots(MLState, cause);
  548. }
  549. #endif MAX_PROCS
  550.  
  551. /* callgc:
  552.  */
  553. static void callgc (MLState, cause, misc_roots, arptr, store_lists, amount)
  554.     MLState_ptr MLState;
  555.     int        cause;        /* the reason for doing GC */
  556.     int        ***misc_roots;    /* vector of ptrs to extra root words */
  557.     int        *arptr;        /* place to put new freespace pointer */
  558.     ML_val_t    *store_lists;    /* vector of list of refs stored into */
  559.     int         amount;         /* amount of space requested */
  560. {
  561.     int amount_desired;
  562.  
  563.     arend = arenabase+arenasize;
  564.     if (cause == CAUSE_GC)
  565.         amount_desired = amount;
  566.     else if (cause == CAUSE_BLAST)
  567.      amount_desired = 4 + arend - (*arptr);
  568.     else
  569.     amount_desired = 0;
  570.     if (arstart == *arptr)
  571.     new_high = old_high; /* no minor needed */
  572.     else  {
  573.     if (gcmessages >= INT_CtoML(3))
  574.         chatting("\n[Minor collection...");
  575.     gc (MLState,
  576.         arstart, arend,
  577.         old_high,arstart,
  578.         old_high,
  579.         &new_high,
  580.         misc_roots,store_lists,
  581.         &shouldFlush1,
  582.         getmore_die, 0);
  583.     {
  584.         int a = new_high-old_high, b =(*arptr)-arstart;
  585.         if (gcmessages >= INT_CtoML(3)) {
  586.               int d = (b+50)/100;
  587.               int p = d > 0 ? a/d : 0;
  588.         chatting(" %d%% used (%d/%d), %d msec]\n",
  589.                   p, a, b, check_gc_timer());
  590.             }
  591.         collected = INT_incr(collected, (a+512)/1024); /* round to nearest K */
  592.         collectedfrom = INT_incr(collectedfrom, (b+512)/1024);
  593.         minorcollections = INT_incr(minorcollections, 1);
  594.     }
  595.  
  596. #ifdef GCMON
  597.     gcmonMinor(arstart,*arptr,old_high,new_high);
  598. #endif
  599.   /* flush i-cache from old_high to new_high -- save values so other procs
  600.      can flush their caches. */
  601.  
  602.     shouldFlush1 = TRUE;
  603.  
  604.     if (shouldFlush1) {
  605.       flushFrom1 = old_high;
  606.       flushTo1   = new_high - old_high;
  607.       FlushICache(flushFrom1, flushTo1);
  608.     }
  609.  
  610. #ifdef GCDEBUG
  611.     checkup (MLState, arstart, new_high);
  612.     clear (new_high, arenabase+arenasize);
  613. #endif
  614.     }
  615.  
  616.     {
  617.     int need_major = 0;
  618.     int was_preserving;
  619.     int gamma = INT_MLtoC(ratio);
  620.  
  621.     if (gamma < 3) gamma = 3;
  622.  
  623.     if ((cause == CAUSE_EXPORT) || (cause == CAUSE_BLAST) || (cause == CAUSE_MAJOR))
  624.         need_major = 1;
  625.     else {
  626.         int cut = arenasize-arenasize/gamma;
  627.         int max = INT_MLtoC(softmax);
  628.         int halfmax = max/2;
  629.         int halfsize = arenasize/2;
  630.         cut = (cut<halfmax ? cut : halfmax);
  631.         cut = (cut>halfsize ? cut : halfsize);
  632.         if (new_high+amount_desired > arenabase+cut)
  633.         need_major = 1;
  634.         else {
  635.         int live_size = amount_desired+new_high-old_high;
  636. #ifdef ADVICE
  637.         if (((arenabase+arenasize-new_high)/2 <= amount_desired*3+100)
  638.         || (minorcollections > old_minorcount+200))
  639.             need_major = 1;
  640. #else
  641.         new_size = compute_new_size(live_size);
  642.         if (new_size > arenasize
  643.         && (increase_heapsize()-new_high)/2 <= amount_desired)
  644.             need_major = 1;
  645. #endif ADVICE
  646.          /*    lastratio = INT_CtoML(arenasize/(live_size/100)); */
  647.        }
  648.     }
  649.     if (cause == CAUSE_BLAST)
  650.         old_high = new_high;
  651.     if (need_major) {
  652.         int        msec0;
  653.         if (gcmessages >= INT_CtoML(1)) {
  654.         chatting("\n[Major collection...");
  655.         msec0 = check_gc_timer();
  656.         }
  657.         was_preserving=preserving; preserving=0;
  658.         if (gc(MLState,
  659.            arenabase, old_high,
  660.            old_high, arenabase+arenasize,
  661.            new_high,
  662.            &new_new_high,
  663.            misc_roots, empty_store_lists,
  664.            &shouldFlush2,
  665.            getmore_must, (cause == CAUSE_BLAST) ? &(MLState->ml_arg) : 0))
  666.         {
  667. #ifdef GCMON
  668.         gcmonMajor (arenabase, old_high, old_high, new_new_high);
  669. #endif
  670.         moveback (old_high, new_new_high, arenabase, misc_roots);
  671.           /* flush i-cache from arenabase to arenabase+new_new_high-old_high if necessary */
  672.  
  673.         /* jgm: looks like the hooks I put in to gc.c don't catch
  674.          * all code string movements -- doing major collections
  675.          * repeatedly while another processor is running/allocating 
  676.          * causes a segmentation violation that goes away when we
  677.          * always do a cache flush.
  678.          */
  679.         shouldFlush2 = TRUE;
  680.  
  681.         if (shouldFlush2) {
  682.           flushFrom2 = arenabase;
  683.           flushTo2   = new_new_high-old_high;
  684.           FlushICache (flushFrom2, flushTo2);
  685.         }
  686.         {
  687.             int a = new_new_high-new_high, b = new_high-arenabase;
  688.                   if (gcmessages >= INT_CtoML(1)) {
  689.                     int d = (b+50)/100;
  690.                     int p = d > 0 ? a/d : 0;
  691.                     chatting(" %d%% used (%d/%d), %d msec]\n",
  692.                           p, a, b, check_gc_timer()-msec0);
  693.                   }
  694.                   collected = INT_incr(collected,(a+512)/1024);
  695.                   collectedfrom = INT_incr(collectedfrom,(b+512)/1024);
  696.           majorcollections = INT_incr(majorcollections,1);
  697.         }
  698.         {
  699.             int live_size = amount_desired+new_new_high-old_high;
  700.             old_high = arenabase+new_new_high-old_high;
  701. #ifdef ADVICE
  702.             new_size = ask_new_size(live_size);
  703. #else
  704.             new_size = compute_new_size(live_size);
  705. #endif
  706.             if (new_size > arenasize) {
  707.             int end = increase_heapsize();
  708.             if ((end-old_high)/2 <= amount_desired)
  709.                 die("\nRan out of memory\n");
  710.             }
  711. #ifdef ADVICE
  712.             else if (new_size < arenasize)
  713.             decrease_heapsize();
  714.             old_size = arenasize;
  715.             old_minorcount = minorcollections;
  716. #else
  717.             else if (new_size < (arenasize/4)*3)
  718.             decrease_heapsize();
  719. #endif
  720.             lastratio = INT_CtoML(arenasize/(live_size/100));
  721.         }
  722.         }
  723.         else {
  724.         if (gcmessages >= INT_CtoML(1))
  725.             chatting("abandoned]\n");
  726.         }
  727.          preserving=was_preserving;
  728.     }
  729.     else
  730.         old_high=new_high;
  731.     }
  732.     arend = arenabase+arenasize;
  733. #ifdef HPPA
  734.     /* on the HP the high bits of pointers have segment bits.
  735.        we can't add them without overflow. */
  736.     arstart = (arend/2 + old_high/2 + 3) & (~3);
  737. #else
  738.     arstart = (((arend+old_high)/2)+3)&(~3);
  739. #endif
  740.     (*arptr) = arstart;
  741.  
  742. } /* end of callgc */
  743.  
  744.  
  745. /* getmore_die:
  746.  */
  747. static int **getmore_die ()
  748. {
  749.     die("bug: insufficient to_space\n");
  750. }
  751.  
  752. int amount_desired;
  753.  
  754. /* decrease_heapsize:
  755.  */
  756. int decrease_heapsize ()
  757. {
  758.     int        p = arenabase+new_size;
  759.     p = (p + pagesize-1 ) & ~(pagesize-1);
  760.     if (p < lastbreak) {
  761.     brk(p);
  762.     arenasize = p-arenabase;
  763.     if (gcmessages >= INT_CtoML(2))
  764.         chatting ("\n[Decreasing heap to %dk]\n",arenasize/1024);
  765.     lastbreak = p;
  766.     }
  767.     return lastbreak;
  768. }
  769.  
  770. /* increase_heapsize:
  771.  * Assume that new_size > arenasize.
  772.  */
  773. int increase_heapsize ()
  774. {
  775.     int        p = arenabase+new_size;
  776.  
  777.   RESTART:;
  778.     p = (p + pagesize-1 ) & ~(pagesize-1);
  779.     if (p == lastbreak) {
  780.     if (gcmessages >= INT_CtoML(2))
  781.         chatting("\nWarning: can't increase heap\n");
  782.     return p;
  783.     }
  784.     else if (brk(p)) {
  785.     if (gcmessages >= INT_CtoML(3))
  786.         chatting("\nWarning: must reduce heap request\n");
  787.     p = (lastbreak+(p-pagesize))/2;
  788.     goto RESTART;
  789.     }
  790.     else {
  791.     lastbreak=p;
  792.     arenasize = p-arenabase;
  793.     if (gcmessages >= INT_CtoML(2))
  794.             chatting("\n[Increasing heap to %dk]\n",arenasize/1024);
  795.         return p;
  796.     }
  797. }
  798.  
  799. int compute_new_size (live_size) 
  800.     int        live_size;
  801. {
  802.     int        new_size;
  803.     int        gamma = INT_MLtoC(ratio);
  804.     int        max = INT_MLtoC(softmax);
  805.  
  806.     if (gamma < 3)
  807.     gamma = 3;
  808.     if (2000000000 / gamma < live_size)
  809.     new_size = 2000000000;
  810.     else
  811.     new_size = live_size*gamma;
  812.     if (max < new_size) {
  813.     int new = 3*live_size;
  814.     new_size = ((new > max) ? new : max);
  815.     }
  816.     return new_size;
  817. }
  818.  
  819. /* getmore_must:
  820.  */
  821. static int **getmore_must ()
  822. {
  823.     int        oldsize = arenasize;
  824.     int        live_size = amount_desired+arenasize+arenabase-old_high;
  825.     int        r;
  826.  
  827.     new_size = compute_new_size(live_size);
  828.     r = increase_heapsize();
  829. #ifdef ADVICE
  830.     while (oldsize == arenasize) {
  831.     chatting ("\nCan't get more memory; waiting\n");
  832.     sleep (10);
  833.     chatting("Trying again\n");
  834.     r = increase_heapsize();
  835.     }
  836. #else
  837.     if (oldsize == arenasize)
  838.     die("\nRan out of memory");
  839. #endif
  840.     return (int **)r;
  841. } /* end of getmore_must */
  842.  
  843.  
  844. #ifdef GETSTORELIST
  845. /* uniq:
  846.  * THIS COULD BE PUT IN ml_getstorelist (in cfuns.c).
  847.  */
  848. ML_val_t uniq (arg)
  849.     ML_val_t    arg;
  850. {
  851.     register ML_val_t *p, q;
  852.  
  853.     for (q = arg;  q != STORLST_nil;  q = STORLST_next(q)) {
  854.     if (STORLST_index(q) == -1) {
  855.         (PTR_MLtoC(q))[-1] = STORLST_objdesc(q);
  856.         (PTR_MLtoC(STORLST_obj(q)))[-1] = 0;
  857.     }
  858.     }
  859.  
  860.     for (q = arg;  q != INT_CtoML(0);  q = REC_SEL(q, 2)) {
  861.     if ((STORLST_objdesc(q) != 0)
  862.     && (STORLST_index(q) >= 0)
  863.     && (STORLST_index(STORLST_obj(q)) != 0)) {
  864.         (PTR_MLtoC(q))[-1] = STORLST_index(STORLST_obj(q));
  865.         (PTR_MLtoC(STORLST_obj(q)))[1] = 0;
  866.     }
  867.     }
  868.  
  869.     for (p = &arg;  *p != STORLST_nil;  p = &(STORLST_next(*p))) {
  870.     if ((PTR_MLtoC(STORLST_obj(*p)))[1] == 0) {
  871.         (PTR_MLtoC(STORLST_obj(*p)))[STORLST_index(*p)] = OBJ_DESC(*p);
  872.         (PTR_MLtoC(*p))[-1] = MAKE_DESC(3, TAG_record);
  873.     }
  874.     }
  875.  
  876.     return arg;
  877.  
  878. } /* end of uniq */
  879. #endif GETSTORELIST
  880.  
  881.  
  882. #ifdef NeXT
  883. /**
  884.  ** This implements sbrk/brk using vm_allocate/vm_deallocate.
  885.  ** Arguments are assumed to be page multiples, and the argument
  886.  ** to brk is assumed to be just after the desired breakpoint.
  887.  **
  888.  ** No relationship between the mapped region and the rest of the
  889.  ** process image is guaranteed, but it is expected that the region
  890.  ** will follow the end of data/bss.
  891.  **
  892.  ** Works with NeXT Mach (software release 0.9).  5/15/89
  893.  **
  894.  ** James William O'Toole Jr.
  895.  **
  896.  **/
  897.  
  898. #include <c.h>            /* TRUE and FALSE */
  899. #ifdef NeXT_3_0
  900. #include <mach/kern_return.h>    /* KERN_whatever */
  901. #include <mach/mach.h>
  902. #else
  903. #include <sys/kern_return.h>    /* KERN_whatever */
  904. #include <mach.h>
  905. #endif
  906.  
  907. extern vm_task_t task_self_;
  908.  
  909. int mach_sbrk_needsinit = TRUE;
  910. int mach_maplimit = 0;
  911. int mach_brkpt = 0;
  912. int mach_quant = 0x800000;
  913. int big_heap = 0x2000000;
  914.  
  915. static int sbrk(incr)
  916.     int incr;
  917. {
  918.     if (incr)
  919.     die("sbrk called with nonzero value");
  920.     if (mach_sbrk_needsinit != FALSE) {
  921.     if (vm_allocate(task_self_, &mach_brkpt, big_heap, TRUE) != KERN_SUCCESS)
  922.         die("vm_allocate failed");
  923.     mach_maplimit = mach_brkpt + big_heap;
  924.     mach_sbrk_needsinit = FALSE;
  925.     }
  926.     return(mach_brkpt);
  927. }
  928.  
  929. static int brk(pos)
  930.     int pos;
  931. {
  932.     if (pos > mach_maplimit)
  933.     return KERN_FAILURE;
  934.     else
  935.     return KERN_SUCCESS;
  936. }
  937.  
  938. #endif NeXT
  939.  
  940.  
  941. /** GCDEBUG routines **/
  942.  
  943. #ifdef GCDEBUG
  944. clear(low,high) int *low, *high;
  945. {int *i;
  946.  chatting("clearing new space...  ");
  947.  for(i=low; i<high; i++) *i=0;
  948.  chatting("done\n");
  949. }
  950.  
  951. int *descriptor;
  952. checkup (MLState, low, high)
  953.     MLState_ptr MLState;
  954.     int *low,*high;
  955. {int *i,*j;
  956.  chatting("checking to_space...  ");
  957.  i = low;
  958.  while (i < high) {
  959.    descriptor = i;
  960.    switch(OBJ_TAG(i)) {
  961.         case TAG_backptr:
  962.         chatting("Uncool backpointer at %#x in to_space\n",i);
  963.         mp_shutdown(MLState,0);
  964.         break;
  965.     case TAG_emb_string: case TAG_emb_reald:
  966.         chatting("Uncool embedded tag at %#x in to_space\n",i);
  967.         mp_shutdown(MLState,0);
  968.         break;
  969.     case TAG_string:
  970.     case TAG_bytearray:
  971.         i += (OBJ_LEN(i)+7)>>2;
  972.         break;
  973.     case TAG_reald:
  974.         i += 3;
  975.         break;
  976.     case TAG_realdarray:
  977.         i += (OBJ_LEN(i)<<1)+1;
  978.         break;
  979.     case TAG_record:
  980.     case TAG_pair:
  981.     case TAG_array:
  982.         j = i + OBJ_LEN(i) + 1;
  983.         while(++i < j) {
  984.             if (! OBJ_isBOXED(*i))
  985.             continue;
  986.             else if ((int*)*i > high) {
  987.             chatting("Uncool pointer %#x at %#x\n", *i,i);
  988.             chatting("Descriptor is at %#x\n",descriptor);
  989.             }
  990.             else if ((int*)*i < low) {
  991.             chatting("Uncool pointer %#x at %#x\n", *i,i);
  992.             chatting("Descriptor is at %#x\n",descriptor);
  993.             }
  994.         }
  995.         break;
  996.     case TAG_forwarded:
  997.         chatting("Uncool forwarding tag at %#x in to_space\n",i);
  998.         mp_shutdown(MLState,0);
  999.         break;
  1000.     default: /* function pointers */
  1001.         chatting("Unexpected even tag %d at %#x in to_space\n",
  1002.              OBJ_LEN(i),i);
  1003.         mp_shutdown(MLState,0);
  1004.         break;
  1005.           }
  1006.  }
  1007.  chatting("done\n");
  1008. }
  1009. #endif    /* GCDEBUG */
  1010.